home *** CD-ROM | disk | FTP | other *** search
/ Australian Personal Computer 2002 November / CD 1 / APC0211D1.ISO / workshop / prog / files / ActivePerl-5.6.1.633-MSWin32.msi / _7d95aa67cbac8bcbfc92f54c7d0b6dca < prev    next >
Encoding:
Text File  |  2002-06-17  |  22.3 KB  |  802 lines
  1. @rem = '--*-Perl-*--
  2. @echo off
  3. if "%OS%" == "Windows_NT" goto WinNT
  4. "C:\p4view\Apps\ActivePerl\MSI\data\ActivePerl\Perl\bin\perl.exe"  -x -S "%0" %1 %2 %3 %4 %5 %6 %7 %8 %9
  5. goto endofperl_ppminst
  6. :WinNT
  7. "C:\p4view\Apps\ActivePerl\MSI\data\ActivePerl\Perl\bin\perl.exe"  -x -S %0 %*
  8. if NOT "%COMSPEC%" == "%SystemRoot%\system32\cmd.exe" goto endofperl_ppminst
  9. if %errorlevel% == 9009 echo You do not have Perl in your PATH.
  10. if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul
  11. goto endofperl_ppminst
  12. @rem ';
  13. #!perl
  14. #line 15
  15. use strict;
  16. use FindBin;
  17. use Data::Dumper;
  18. use PPM::Config;
  19.  
  20. my $VERSION;
  21. BEGIN { $VERSION = '3.05' }
  22.  
  23. my %INST;
  24. my %CONF;
  25. my %keys = (
  26.         root        => 1,
  27.         tempdir        => 1,
  28.  
  29.         ARCHITECTURE    => 0,
  30.         CPU            => 0,
  31.         OSVALUE        => 0,
  32.         OSVERSION        => 0,
  33.         PERLCORE        => 0,
  34.         TARGET_TYPE        => 0,
  35.         LANGUAGE        => 0,
  36.         VERSION        => 0,
  37.        );
  38. my $ERR;
  39.  
  40. #============================================================================
  41. # Register a dummy object which implements the required interface.
  42. #============================================================================
  43. my $i = Implementation->new($ENV{PPM_PORT});
  44.  
  45. #============================================================================
  46. # Command Implementors
  47. #============================================================================
  48. package Implementation;
  49. use base qw(PPM::InstallerClient);
  50.  
  51. use Config;
  52. use Fcntl qw(LOCK_SH LOCK_UN LOCK_EX);
  53. use PPM::Compat;
  54. use PPM::PPD;
  55. use PPM::Search;
  56. use Data::Dumper;
  57.  
  58. # There's a bug in ExtUtils::Install in perl 5.6.1.
  59. # Also exists in ActivePerl 522 (line 168)
  60. BEGIN {
  61.     local $^W;
  62.     require ExtUtils::Install;
  63. }
  64.  
  65. # Query installed packages: returns a list of records about the results.
  66. sub query {
  67.     my $inst = shift;
  68.     my $query = shift;
  69.     my $case = shift;
  70.  
  71.     load_pkgs();
  72.     my @ppds = map { $_->{ppd} } values %INST;
  73.     my $compiled = PPM::PPD::Search->new($query, $case);
  74.     unless ($compiled->valid) {
  75.     $ERR = $compiled->error;
  76.     return 0;
  77.     }
  78.     $ERR = '';
  79.     my @matches = $compiled->search(@ppds);
  80.     return 1, map { $_->ppd } @matches;
  81. }
  82.  
  83. sub properties {
  84.     my $inst = shift;
  85.     my $pkg = shift;
  86.     if (pkg_installed($pkg) && load_pkg($pkg)) {
  87.     return ($INST{$pkg}{ppd}->ppd,
  88.         $INST{$pkg}{pkg}{INSTDATE},
  89.         $INST{$pkg}{pkg}{LOCATION});
  90.     }
  91.     $ERR = "package '$pkg' is not installed.";
  92.     return ();
  93. }
  94.  
  95. sub dependents {
  96.     my $inst = shift;
  97.     my $pkg = shift;
  98.     if (pkg_installed($pkg) && load_pkg($pkg)) {
  99.     return @{ $INST{$pkg}{pkg}{dependents} || [] };
  100.     }
  101.     undef;
  102. }
  103.  
  104. sub remove {
  105.     my ($inst, $pkg, $verbose) = @_;
  106.  
  107.     if (pkg_installed($pkg) && load_pkg($pkg)) {
  108.  
  109.     # Is there an uninstall script?
  110.     my $u_script = eval {
  111.         $INST{$pkg}{ppd}->find_impl_raw($inst)->uninstall_script
  112.     };
  113.     if ($u_script) {
  114.         my %opts = (
  115.         PPM_INSTARCHLIB => $Config{installsitearch},
  116.         PPM_INSTPACKLIST => $INST{$pkg}{pkg}{INSTPACKLIST},
  117.         PPM_INSTROOT => $INST{$pkg}{pkg}{INSTROOT},
  118.         PPM_ACTION => 'uninstall',
  119.         );
  120.         $inst->run_script(pkg_uninstaller($pkg), $u_script, \%opts)
  121.           or return 0;
  122.     }
  123.  
  124.     my $packlist = $INST{$pkg}{pkg}{INSTPACKLIST};
  125.     (my $altpacklist = $packlist) =~ s<\Q$CONF{ARCHITECTURE}\E[\\/]><>i;
  126.     eval {
  127.         if (-f $packlist) {
  128.         ExtUtils::Install::uninstall($packlist, $verbose, 0);
  129.         }
  130.         elsif (-f $altpacklist) {
  131.         ExtUtils::Install::uninstall($altpacklist, $verbose, 0);
  132.         }
  133.     };
  134.     $ERR = "$@" and return 0 if $@;
  135.  
  136.     # Update html table of contents, if ActivePerl::DocTools is installed:
  137.     if (eval { require ActivePerl::DocTools; 1 }) {
  138.         ActivePerl::DocTools::WriteTOC();
  139.     }
  140.  
  141.     # Remove the package and references to it:
  142.     my $ppd_ref = $INST{$pkg}{ppd};
  143.     my @prereqs;
  144.     eval { @prereqs = $ppd_ref->find_impl_raw($inst)->prereqs };
  145.     del_dependent($_->name, $ppd_ref->name) for @prereqs;
  146.     purge_pkg($pkg);
  147.     }
  148.     else {
  149.     $ERR = "package '$pkg' not installed.";
  150.     return 0;
  151.     }
  152.     return 1;
  153. }
  154.  
  155. sub precious {
  156.     return @{$CONF{precious}};
  157. }
  158.  
  159. sub bundled {
  160.     return @{$CONF{bundled}};
  161. }
  162.  
  163. sub upgrade {
  164.     my ($inst, $pkg, $ppmpath, $ppd, $repos, $verbose) = @_;
  165.     local %ENV = %ENV;
  166.     $ENV{PPM_ACTION} = 'upgrade';
  167.     $inst->install($pkg, $ppmpath, $ppd, $repos, $verbose);
  168. }
  169.  
  170. # This sub is called when the frontend has found an implementation suitable
  171. # for this target, and is double-checking whether we can actually install this
  172. # "content-type".
  173. sub can_install {
  174.     my ($inst, $lang, $version, $compat_type) = @_;
  175.     return 0 unless $lang eq $inst->config_get('LANGUAGE');
  176.     
  177.     # There are two distinct version number schemes for Perl: 5.00x_yy, and
  178.     # 5.x.y. At least, those are the ones I care about. To handle both, I'm
  179.     # going to detect the new format and demote it to the old format. Then I
  180.     # can compare using a regular numeric comparison. The reason I use the old
  181.     # one is so that the PPM3 backend will still work with pre-5.6.0 perls.
  182.     my @parts = split /\./, $version;
  183.     if (@parts > 2) {
  184.     $version = sprintf("%i.%.03i%.03i", @parts);
  185.     }
  186.     return $] >= $version;
  187. }
  188.  
  189. sub install {
  190.     my ($inst, $pkg, $ppmpath, $ppd, $repos, $verbose) = @_;
  191.     use Cwd qw(cwd);
  192.     my $cwd = cwd();
  193.     my $ppd_obj = PPM::PPD->new($ppd);
  194.  
  195.     # Install:
  196.     # 1. chdir to temp directory
  197.     chdir $ppmpath or do {
  198.     $ERR = "can't chdir to $ppmpath: $!";
  199.     return 0;
  200.     };
  201.     chdir $pkg; # this is expected to fail!
  202.  
  203.     use ActiveState::RelocateTree qw(relocate spongedir);
  204.     relocate (
  205.     to      => '.',
  206.     inplace => 1,
  207.     search  => spongedir('ppm'),
  208.     replace => $Config{prefix},
  209.     ) if $Config{osname} ne 'MSWin32';
  210.  
  211.     # 2. set up the install parameters:
  212.     my ($packlist, %opts, %inst_opts);
  213.     {
  214.     my $inst_archlib = $Config{installsitearch};
  215.     my $inst_root = $Config{prefix};
  216.     $packlist = MM->catfile("$inst_archlib/auto",
  217.                 split(/-/, $pkg), ".packlist");
  218.     
  219.     # Copied from ExtUtils::Install
  220.     my $INST_LIB = MM->catdir(MM->curdir, "blib", "lib");
  221.     my $INST_ARCHLIB = MM->catdir(MM->curdir, "blib", "arch");
  222.     my $INST_BIN = MM->catdir(MM->curdir, "blib", "bin");
  223.     my $INST_SCRIPT = MM->catdir(MM->curdir, "blib", "script");
  224.     my $INST_MAN1DIR = MM->catdir(MM->curdir, "blib", "man1");
  225.     my $INST_MAN3DIR = MM->catdir(MM->curdir, "blib", "man3");
  226.     my $INST_HTMLDIR = MM->catdir(MM->curdir, "blib", "html");
  227.     my $INST_HTMLHELPDIR = MM->catdir(MM->curdir, "blib", "htmlhelp");
  228.  
  229.     my $inst_script = $Config{installscript};
  230.     my $inst_man1dir = $Config{installman1dir};
  231.     my $inst_man3dir = $Config{installman3dir};
  232.     my $inst_bin = $Config{installbin};
  233.     my $inst_htmldir = $Config{installhtmldir};
  234.     my $inst_htmlhelpdir = $Config{installhtmlhelpdir};
  235.     my $inst_lib = $Config{installsitelib};
  236.     $inst_htmldir ||= "$inst_bin/../html";
  237.     $inst_htmlhelpdir ||= "$inst_bin/../html";
  238.  
  239.     # %inst_opts is used for ExtUtils::Install installs.
  240.     %opts = (
  241.         PPM_INSTARCHLIB => $inst_archlib,
  242.         PPM_INSTROOT => $inst_root,
  243.         PPM_INSTPACKLIST => $packlist,
  244.         PPM_ACTION => (
  245.         defined $ENV{PPM_ACTION} ? $ENV{PPM_ACTION} : 'install'
  246.         ),
  247.         PPM_NEW_VERSION => $ppd_obj->version,
  248.         (
  249.         pkg_installed($pkg) && load_pkg($pkg)
  250.         ? (PPM_PREV_VERSION => $INST{$pkg}{ppd}->version)
  251.         : ()
  252.         ),
  253.     );
  254.     %inst_opts = (
  255.         read => $packlist,
  256.         write => $packlist,
  257.         $INST_LIB => $inst_lib,
  258.         $INST_ARCHLIB => $inst_archlib,
  259.         $INST_BIN => $inst_bin,
  260.         $INST_SCRIPT => $inst_script,
  261.         $INST_MAN1DIR => $inst_man1dir,
  262.         $INST_MAN3DIR => $inst_man3dir,
  263.         $INST_HTMLDIR => $inst_htmldir,
  264.         $INST_HTMLHELPDIR => $inst_htmlhelpdir
  265.     );
  266.     if ($CONF{root} && $CONF{root} !~ /^\Q$inst_root\E$/i) {
  267.         my $root = $CONF{root};
  268.         $_ =~ s/\Q$inst_root/$root\E/i for values %inst_opts;
  269.         $_ =~ s/\Q$inst_root/$root\E/i for values %opts;
  270.         $inst_root = $root;
  271.     }
  272.     }
  273.  
  274.     # 3. Install the package.
  275.     #    This operates slightly differently than PPM2. First,
  276.     #    ExtUtils::Install is only called if q(blib) exists and is a
  277.     #    directory. Next, the install script is run. If it fails, then the
  278.     #    results of ExtUtils::Install are backed out.
  279.     my $inst_blib = -d "blib";
  280.     my $inst_script = eval { $ppd_obj->find_impl_raw($inst)->install_script };
  281.     if ($inst_blib) {
  282.     while (1) {
  283.         eval {
  284.         my $verbose = $verbose - 1; # $verbose < 0 implies silence.
  285.         ExtUtils::Install::install(
  286.             {%inst_opts},
  287.             $verbose,0,0
  288.         );
  289.         };
  290.         # install might have croaked in another directory
  291.         chdir $ppmpath;
  292.         # Can't remove some DLLs, but we can rename them and try again.
  293.         if ($@ && $@ =~ /Cannot forceunlink (\S+)/) {
  294.         my $oldname = $1;
  295.         $oldname =~ s/:$//;
  296.         my $newname = $oldname . "." . time();
  297.         unless (rename($oldname, $newname)) {
  298.             $ERR = "renaming $oldname to $newname: $!";
  299.             return 0;
  300.         }
  301.         }
  302.         # Some other error
  303.         elsif($@) {
  304.         $ERR = "$@";
  305.         return 0;
  306.         }
  307.         else { last; }
  308.     }
  309.     }
  310.     if ($inst_script) {
  311.     $inst->run_script("install_script", $inst_script, \%opts, $verbose)
  312.         or do {
  313.         # Back out ExtUtils::Install
  314.         if ($inst_blib) {
  315.         ExtUtils::Install::uninstall($packlist, $verbose, 0);
  316.         }
  317.         return 0;
  318.     };
  319.     }
  320.     chdir $cwd;
  321.  
  322.     # 4. update html table of contents, if ActivePerl::DocTools is installed:
  323.     if (eval { require ActivePerl::DocTools; 1 }) {
  324.     ActivePerl::DocTools::WriteTOC();
  325.     }
  326.  
  327.     # Add the package to the list of installed packages
  328.     $INST{$pkg} = {
  329.     pkg => {
  330.         INSTDATE => scalar localtime,
  331.         LOCATION => $repos,
  332.         INSTROOT => $opts{PPM_INSTROOT},
  333.         INSTPACKLIST => $packlist,
  334.            },
  335.     ppd => $ppd_obj,
  336.     };
  337.     save_pkg($pkg, "$ppmpath/uninstall_script");
  338.  
  339.     # "Register" the package as dependent on each prerequisite:
  340.     my @prereqs;
  341.     eval { @prereqs = $ppd_obj->find_impl_raw($inst)->prereqs };
  342.     add_dependent($_->name, $pkg) for @prereqs;
  343.  
  344.     return 1;
  345. }
  346.  
  347. sub config_keys {
  348.     map { [$_, $keys{$_}] } keys %keys;
  349. }
  350.  
  351. sub _str {
  352.     my $a = shift;
  353.     return '' unless defined $a;
  354.     $a;
  355. }
  356.  
  357. sub config_info {
  358.     map { [$_, _str($CONF{$_})] } keys %keys;
  359. }
  360.  
  361. sub config_set {
  362.     my $inst = shift;
  363.     my ($key, $val) = @_;
  364.     unless (defined $keys{$key}) {
  365.     $ERR = "unknown config key '$key'";
  366.     return 0;
  367.     }
  368.  
  369.     $CONF{$key} = $val;
  370.     save_conf();
  371.     return 1;
  372. }
  373.  
  374. sub config_get {
  375.     my $inst = shift;
  376.     my $key = shift;
  377.     unless (defined $key and exists $keys{$key}) {
  378.     $key = '' unless defined $key;
  379.     $ERR = "unknown config key '$key'";
  380.     return undef;
  381.     }
  382.     _str($CONF{$key});
  383. }
  384.  
  385. sub error_str {
  386.     defined $ERR ? $ERR : 'No error';
  387. }
  388.  
  389. #----------------------------------------------------------------------------
  390. # Utilities
  391. #----------------------------------------------------------------------------
  392.  
  393. # This can deal with files as well as directories
  394. sub abspath {
  395.     use Cwd qw(abs_path);
  396.     my ($path, $file) = shift;
  397.     if (-f $path) {
  398.         my @p = split '/', $path;
  399.         $path = join '/', @p[0..$#p-1]; # can't use -2 in a range
  400.         $file = $p[-1];
  401.     }
  402.     $path = abs_path($path || '.');
  403.     return ($path, $file, defined $file ? join '/', $path, $file : ())
  404.       if wantarray;
  405.     return defined $file ? join '/', $path, $file : $path;
  406. }
  407.  
  408. sub run_script {
  409.     my $o    = shift;
  410.     my $file    = shift;
  411.     my $inst    = shift;
  412.     my $setenv    = shift;
  413.     my $verbose    = shift;
  414.     my ($exec, $href, $content) = map { $inst->$_ } qw(exec href script);
  415.  
  416.     # Export %setenv to %ENV:
  417.     local %ENV = %ENV;
  418.     my %setenv = (
  419.     PPM_VERSION => $VERSION,
  420.     PPM_PERL => $Config{perlpath},
  421.     %$setenv,
  422.     );
  423.     $ENV{$_} = $setenv->{$_} for keys %setenv;
  424.  
  425.     # Evaluate special case of EXEC:
  426.     $exec =~ s/\bPPM_PERL\b/$Config{perlpath}/i;
  427.  
  428.     # Four cases:
  429.     # 1. !EXEC && !HREF: system($_) for split ';;';
  430.     # 2. !EXEC &&  HREF: system($_) for split '\n';
  431.     # 3.  EXEC && !HREF: split ';;' => $tmpfile; system($exec, $tmpfile);
  432.     # 4.  EXEC &&  HREF: system($exec, $file);
  433.  
  434.     if (not $exec and not $href) {
  435.     for (split ';;', $content) {
  436.         system($_) == 0 and next;
  437.         $ERR = "system() return non-zero value ($?): '$_'";
  438.         return 0;
  439.     }
  440.     }
  441.     elsif (not $exec) {    # and $href (of course)
  442.     local *INPUT;
  443.     open (INPUT, $file) or do {
  444.         $ERR = "can't open $file: $!";
  445.         return 0;
  446.     };
  447.     while (<INPUT>) {
  448.         system($_) == 0 and next;
  449.         $ERR = "system() returned non-zero value ($?): '$_'";
  450.         return 0;
  451.     }
  452.     }
  453.     elsif (not $href) { # and $exec (of course)
  454.     local *INPUT;
  455.     open (INPUT, "> $file") or die "can't write $file: $!";
  456.     print INPUT "$_\n" for (split ';;', $content);
  457.     close (INPUT) or die "can't close $file: $!";
  458.     system("$exec $file") == 0 or do {
  459.         $ERR = "system() returned non-zero value ($?): '$exec $file'";
  460.         return 0;
  461.     };
  462.     # only a convenience: this whole directory will be removed.
  463.     unlink $file;
  464.     }
  465.     else {
  466.     $exec =~ s/\bSELF\b/abspath($file)/ei and chmod(0777, $file);
  467.     -f $file or do {
  468.         $ERR = "can't run '$exec $file': $!";
  469.         return 0;
  470.     };
  471.     system("$exec $file") == 0 or do {
  472.         $ERR = "(un)install script failed: '$exec $file'";
  473.         return 0;
  474.     };
  475.     }
  476.     $ERR = "";
  477.     return 1;
  478. }
  479.  
  480. sub abs_packlist {
  481.     my $pl = shift;
  482.     $pl =~ s[\%SITELIB\%][$Config{sitelib}]g;
  483.     unless (-f $pl) {
  484.     my $i = $^O eq 'MSWin32' ? '(?i)' : '';
  485.     $pl =~ s[$i^\Q$Config{sitelib}\E][$Config{sitearch}];
  486.     return undef unless -f $pl;
  487.     }
  488.     return $pl;
  489. }
  490.  
  491. #============================================================================
  492. # Settings and packages
  493. #============================================================================
  494. my ($conf_dir, $conf, $conf_obj);
  495. BEGIN {
  496.     # By putting an invalid package character in the directory, we're making
  497.     # sure no real package could overwrite our settings, and vice versa.
  498.     $conf_dir = PPM::Config::tree_conf_dir();
  499.     $conf = join '/', $conf_dir, 'ppm.cfg';
  500. }
  501.  
  502. # Loads the configuration file and populates %CONF
  503. sub load_conf {
  504.     $conf_obj = PPM::Config->new->loadfile($conf);
  505.     %CONF = $conf_obj->config;
  506.  
  507.     # Special values; set them here
  508.     $CONF{ARCHITECTURE} = $Config{archname};
  509.     $CONF{PERLCORE} = $Config{version};
  510.     $CONF{TARGET_TYPE} = "perl";
  511.     $CONF{LANGUAGE} = "Perl";
  512.     $CONF{VERSION} = $VERSION;
  513.     $CONF{OSVALUE} = $^O;
  514.     $CONF{OSVERSION} = join(
  515.     ',',
  516.     (((split '\.', $Config{osvers}), (0) x 4)[0..3])
  517.     );
  518. }
  519.  
  520. # Saves %CONF to the configuration file
  521. sub save_conf {
  522.     $conf_obj->merge(\%CONF);
  523.     # Make the file writeable if it isn't already:
  524.     chmod 0666, $conf;
  525.     $conf_obj->save($conf);
  526. }
  527.  
  528. # Loads the given package into $INST{$pkg}. Returns true if the package could
  529. # be loaded, false otherwise.
  530. sub load_pkg {
  531.     my $pkg = shift;
  532.  
  533.     return 1 if exists $INST{$pkg};
  534.  
  535.     return 0 unless -f "$conf_dir/$pkg.ppd";
  536.     return 0 unless -f "$conf_dir/$pkg.pkg";
  537.  
  538.     my $ppdref = PPM::PPD->new("$conf_dir/$pkg.ppd");
  539.     my $pkgfile = "$conf_dir/$pkg.pkg";
  540.     my $pkgref = PPM::Config->new->loadfile($pkgfile);
  541.  
  542.     $INST{$pkg}{ppd} = $ppdref;
  543.     $INST{$pkg}{pkg} = $pkgref->config;
  544.  
  545.     # Substitute the %SITELIB% variable properly.
  546.     $INST{$pkg}{pkg}{INSTPACKLIST} =
  547.     abs_packlist($INST{$pkg}{pkg}{INSTPACKLIST});
  548.     defined $INST{$pkg}{pkg}{INSTPACKLIST}
  549.     or do { purge_pkg($pkg); return 0 };
  550.  
  551.     return 1;
  552. }
  553.  
  554. # Saves the given package from $INST{$pkg}.
  555. sub save_pkg {
  556.     my $pkg = shift;
  557.     my $uninst = shift;
  558.     return 0 unless exists $INST{$pkg};
  559.  
  560.     # the PPD file:
  561.     my $ppdfile = "$conf_dir/$pkg.ppd";
  562.     if (-f $ppdfile) {
  563.     unlink $ppdfile        or die "$0: can't delete $ppdfile: $!";
  564.     }
  565.     open PPD, "> $ppdfile"    or die "$0: can't write $ppdfile: $!";
  566.     print PPD $INST{$pkg}{ppd}->ppd;
  567.     close PPD            or die "$0: can't close $ppdfile: $!";
  568.  
  569.     # the PKG file:
  570.     my $c = PPM::Config->new;
  571.     $c->load($INST{$pkg}{pkg});
  572.     $c->save("$conf_dir/$pkg.pkg");
  573.  
  574.     # save the uninstall script:
  575.     if ($uninst && -f $uninst) {
  576.     my $saveto = "$conf_dir/$pkg.u";
  577.     use File::Copy qw(copy);
  578.     copy($uninst, $saveto);
  579.     }
  580.     return 1;
  581. }
  582.  
  583. sub add_dependent {
  584.     my $package = shift;
  585.     my $dependent = shift;
  586.     return 0 unless load_pkg($package);
  587.     push @{$INST{$package}{pkg}{dependents}}, $dependent;
  588.     save_pkg($package);
  589. }
  590.  
  591. sub del_dependent {
  592.     my $package = shift;
  593.     my $dependent = shift;
  594.     return 0 unless load_pkg($package);
  595.     @{$INST{$package}{pkg}{dependents}}
  596.       = grep { $_ ne $dependent }
  597.     @{$INST{$package}{pkg}{dependents}};
  598.     save_pkg($package);
  599. }
  600.  
  601. sub purge_pkg {
  602.     my $pkg = shift;
  603.  
  604.     # The PPD file:
  605.     my $ppdfile = "$conf_dir/$pkg.ppd";
  606.     if (-f $ppdfile) {
  607.     unlink $ppdfile        or die "$0: can't delete $ppdfile: $!";
  608.     }
  609.  
  610.     # The %INST entry:
  611.     delete $INST{$pkg};
  612.  
  613.     # The PKG file:
  614.     my $pkgfile = "$conf_dir/$pkg.pkg";
  615.     if (-f $pkgfile) {
  616.     unlink $pkgfile        or die "$0: can't delete $pkgfile: $!";
  617.     }
  618.  
  619.     # The uninstall file:
  620.     my $ufile = "$conf_dir/$pkg.u";
  621.     if (-f $ufile) {
  622.     unlink $ufile        or die "$0: can't delete $ufile: $!";
  623.     }
  624.  
  625.     return 1;
  626. }
  627.  
  628. sub pkg_uninstaller {
  629.     my $pkg = shift;
  630.     return "$conf_dir/$pkg.u";
  631. }
  632.  
  633. # Load all packages: only needed when doing an advanced query
  634. sub load_pkgs {
  635.     my @pkgs = map { s/\.ppd$//; s!.*/([^/]+)$!$1!g; $_ } #!
  636.       glob "$conf_dir/*.ppd"; 
  637.     load_pkg($_) for @pkgs;
  638. }
  639.  
  640. sub pkg_installed {
  641.     my $pkg = shift;
  642.     return -f "$conf_dir/$pkg.ppd" && -f "$conf_dir/$pkg.pkg";
  643. }
  644.  
  645. # PPM2 compatibility: load the ppm.xml file and synchronize PPM3 with it. If
  646. # the person has loaded things with PPM2 since the last "sync", they will be
  647. # sucked in.
  648. sub import_ppm2 {
  649.     my $ppm_xml = "$Config{installsitelib}/ppm.xml";
  650.     return () unless -f $ppm_xml;
  651.     my ($conf, $reps, $inst, $cmd, $extra) = ({}, {}, {}, {}, {});
  652.     eval {
  653.     PPM::Compat::read_ppm_xml($ppm_xml, $conf, $reps, $inst, $cmd, $extra);
  654.     };
  655.     return () if $@;
  656.     for my $ppm2_pkg (keys %$inst) {
  657.     next unless ref $inst->{$ppm2_pkg} eq 'HASH';
  658.     my $pkg_file = "$conf_dir/$ppm2_pkg.pkg";
  659.     my $ppd_file = "$conf_dir/$ppm2_pkg.ppd";
  660.     next if -f $pkg_file and -f $ppd_file;
  661.  
  662.     # At this point, we have _either_ a package installed with PPM2, or a
  663.     # package deleted with PPM3. Check whether the .packlist file is
  664.     # installed to be sure.
  665.     next unless abs_packlist($inst->{$ppm2_pkg}{INSTPACKLIST});
  666.  
  667.     local (*PKG, *PPD);
  668.     open (PKG, "> $pkg_file")
  669.         or do { $ERR = "can't write to $pkg_file: $!"; next };
  670.     print PKG "$_: $inst->{$ppm2_pkg}{$_}\n" for qw(
  671.         INSTDATE
  672.         INSTPACKLIST
  673.         INSTROOT
  674.         LOCATION
  675.     );
  676.     close PKG;
  677.     open PPD, "> $ppd_file"
  678.         or do { $ERR = "can't write to $ppd_file: $!"; next };
  679.     print PPD $inst->{$ppm2_pkg}{ppd};
  680.     close PPD;
  681.     }
  682.     ($conf, $reps, $inst, $cmd, $extra);
  683. }
  684.  
  685. # PPM2 compatibility: export the ppm.xml file based on the PPM3 information.
  686. # To ensure that we don't forget about changes to ppm.xml which happened
  687. # during the lifetime of this ppm3, we force a reload of ppm2 (just in case).
  688. sub save_ppm2 {
  689.     my ($conf, $reps, $inst, $cmd, $extra) = import_ppm2();
  690.     load_pkgs();
  691.  
  692.     # If the file wasn't found, write out some default values:
  693.     $conf = {
  694.     tempdir => $ENV{TEMP} || $ENV{TMP} || $^O eq 'MSWin32' ? 'C:\Temp' : '/tmp',
  695.     downloadbytes => 16384,
  696.     } unless defined $conf;
  697.     $extra = {
  698.     CLEAN => 1,
  699.     CONFIRM => 1,
  700.     FORCEINSTALL => 0,
  701.     MORE => 24,
  702.     TRACE => 0,
  703.     TRACEFILE => 'PPM.LOG',
  704.     VERBOSE => 1,
  705.     } unless defined $extra;
  706.     $inst = {
  707.     root => config_get(undef, 'root'),
  708.     precious => [precious()],
  709.     } unless defined $inst;
  710.     $reps = {
  711.     'ActiveState Package Repository' => {
  712.         url => PPM::Compat::repository('ppm2'),
  713.     },
  714.     } unless defined $reps;
  715.  
  716.     # Can't rely on XML::Simple being installed, so I'll just print out the
  717.     # ppm.xml file by hand (ugh).
  718.     my $ppm_xml = "$Config{installsitelib}/ppm.xml";
  719.     local *PPMXML;
  720.     open PPMXML, "> $ppm_xml"
  721.     or do { $ERR = "can't write $ppm_xml: $!"; return 0 };
  722.     my $OSVALUE = config_get(undef, "OSVALUE");
  723.     my $OSVERSION = config_get(undef, "OSVERSION");
  724.     my @opts;
  725.     my @REPS;
  726.     {
  727.     local $^W; # no uninitialized warnings, please
  728.     push @opts, qq{BUILDDIR="$conf->{tempdir}"};
  729.     push @opts, qq{CLEAN="$extra->{CLEAN}"};
  730.     push @opts, qq{CONFIRM="$extra->{CONFIRM}"};
  731.     push @opts, qq{DOWNLOADSTATUS="$conf->{downloadbytes}"};
  732.     push @opts, qq{FORCEINSTALL="$extra->{FORCEINSTALL}"};
  733.     push @opts, qq{IGNORECASE="$cmd->{'case-sensitivity'}"};
  734.     push @opts, qq{MORE="$extra->{MORE}"};
  735.     push @opts, qq{ROOT="$inst->{root}"};
  736.     push @opts, qq{TRACE="$extra->{TRACE}"};
  737.     push @opts, qq{TRACEFILE="$extra->{TRACEFILE}"};
  738.     push @opts, qq{VERBOSE="$extra->{VERBOSE}"};
  739.  
  740.     for my $rep (keys %$reps) {
  741.         my ($smry, $loc);
  742.         if ($reps->{$rep}{url} eq PPM::Compat::repository('ppm3')) {
  743.         $reps->{$rep}{url} = PPM::Compat::repository('ppm2');
  744.         $smry = $reps->{$rep}{url} =~ m[^[^:]+://[^?]+\?]
  745.             ? "fetch_summary"
  746.             : "";
  747.         }
  748.         $loc = $reps->{$rep}{url};
  749.         my @extra;
  750.         defined $reps->{$rep}{username}
  751.         and push @extra, qq{USERNAME="$reps->{$rep}{username}"};
  752.         defined $reps->{$rep}{password}
  753.         and push @extra, qq{PASSWORD="$reps->{$rep}{password}"};
  754.         push @REPS, <<REP;
  755.     <REPOSITORY LOCATION="$loc" NAME="$rep" SUMMARYFILE="$smry" @extra />
  756. REP
  757.     }
  758.     }
  759.     my $ppmprecious = join ';', @{$inst->{precious} || []};
  760.     print PPMXML <<HEADER;
  761. <PPMCONFIG>
  762.     <PPMVER>2,1,5,0</PPMVER>
  763.     <PLATFORM CPU="x86" OSVALUE="$OSVALUE" OSVERSION="$OSVERSION" />
  764.     <OPTIONS @opts />
  765. @REPS
  766.     <PPMPRECIOUS>$ppmprecious</PPMPRECIOUS>
  767. HEADER
  768.  
  769.     # Print out the <PACKAGE>s
  770.     for my $pkg (sort keys %INST) {
  771.     next if $pkg eq 'PPM-Agent-Perl';
  772.     next if $pkg eq 'PPM-Shell';
  773.     my $p = $INST{$pkg}{pkg};
  774.     (my $ppd = $INST{$pkg}{ppd}->ppd) =~ s#^<\?xml.*?\?>##;
  775.     print PPMXML <<INSTPKG;
  776.     <PACKAGE NAME="$pkg">
  777.     <LOCATION>$p->{LOCATION}</LOCATION>
  778.     <INSTPACKLIST>$p->{INSTPACKLIST}</INSTPACKLIST>
  779.     <INSTROOT>$p->{INSTROOT}</INSTROOT>
  780.     <INSTDATE>$p->{INSTDATE}</INSTDATE>
  781.     <INSTPPD>
  782. $ppd
  783.     </INSTPPD>
  784.     </PACKAGE>
  785. INSTPKG
  786.     }
  787.     print PPMXML <<FOOTER;
  788. </PPMCONFIG>
  789. FOOTER
  790. }
  791.  
  792. BEGIN {
  793.     import_ppm2();
  794.     load_conf();
  795. }
  796. END {
  797.     save_ppm2();
  798. }
  799.  
  800. __END__
  801. :endofperl_ppminst
  802.